home *** CD-ROM | disk | FTP | other *** search
/ HAM Radio 1997 / HAM Radio 1997.iso / vcls / jbmbtn / jbmbtn.pas < prev    next >
Pascal/Delphi Source File  |  1996-04-08  |  8KB  |  290 lines
  1. unit Jbmbtn;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, Buttons, Menus;
  8.  
  9. const
  10.   nullchar = chr(0);
  11.  
  12. type
  13.   TMenuBitBtn = class(TBitBtn)
  14.   private
  15.     FPopUpMenu: TPopupMenu;
  16.     procedure WMChar(var Message: TWMChar); message WM_CHAR;
  17.  public
  18.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  19.       X, Y: Integer); override;
  20.   published
  21.     property MenuPopup: TPopupMenu read FPopupMenu write FPopupMenu;
  22.   end;
  23.  
  24. type
  25.   TMenuButton = class(TButton)
  26.   private
  27.     FPopUpMenu: TPopupMenu;
  28.     procedure WMChar(var Message: TWMChar); message WM_CHAR;
  29.   public
  30.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  31.         X, Y: Integer); override;
  32.   published
  33.     property MenuPopup: TPopupMenu read FPopupMenu write FPopupMenu;
  34.   end;
  35.  
  36. type
  37.   TListBitBtn = class(TBitBtn)
  38.   private
  39.     FItems: TStrings;
  40.     FItemIndex: Integer;
  41.     FOnChange: TNotifyEvent;
  42.     FItemChecked: Boolean;
  43.     procedure SetItems(Items: TStrings);
  44.     procedure WMCommand(var Message: TMessage); message WM_COMMAND;
  45.     procedure WMChar(var Message: TWMChar); message WM_CHAR;
  46.   public
  47.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  48.       X, Y: Integer); override;
  49.     constructor Create(AOwner: TComponent); override;
  50.     destructor destroy; override;
  51.   published
  52.     property Items: TStrings read FItems write SetItems;
  53.     property ItemIndex: Integer read FItemIndex write FItemIndex;
  54.     property ItemChecked: Boolean read FItemChecked write FItemChecked;
  55.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  56.   end;
  57.  
  58.   type
  59.   TListButton = class(TButton)
  60.   private
  61.     FItems: TStrings;
  62.     FItemIndex: Integer;
  63.     FOnChange: TNotifyEvent;
  64.     FItemChecked: Boolean;
  65.     procedure SetItems(Items: TStrings);
  66.     procedure WMCommand(var Message: TMessage); message WM_COMMAND;
  67.     procedure WMChar(var Message: TWMChar); message WM_CHAR;
  68.   public
  69.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  70.       X, Y: Integer); override;
  71.     constructor Create(AOwner: TComponent); override;
  72.     destructor destroy; override;
  73.   published
  74.     property Items: TStrings read FItems write SetItems;
  75.     property ItemIndex: Integer read FItemIndex write FItemIndex;
  76.     property ItemChecked: Boolean read FItemChecked write FItemChecked;
  77.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  78.   end;
  79.  
  80.  
  81. procedure Register;
  82.  
  83. implementation
  84.  
  85. procedure Register;
  86. begin
  87.   RegisterComponents('Samples', [TMenuBitBtn]);
  88.   RegisterComponents('Samples', [TMenuButton]);
  89.   RegisterComponents('Samples', [TListBitBtn]);
  90.   RegisterComponents('Samples', [TListButton]);
  91. end;
  92.  
  93.  
  94. {-----------------------------------------------------------------------------
  95.  TListBitBtn
  96. -----------------------------------------------------------------------------}
  97.  
  98. constructor TListBitBtn.Create(AOwner: TComponent);
  99. begin
  100.   inherited Create(AOwner);
  101.   Fitems := TStringList.Create;
  102.   ItemIndex := -1;
  103. end;
  104.  
  105. destructor TListBitBtn.Destroy;
  106. begin
  107.   Fitems.Free;
  108.   Inherited destroy;
  109. end;
  110.  
  111. procedure TListBitBtn.WMChar(var Message: TWMChar);
  112. begin
  113.   if Message.CharCode = VK_SPACE Then PostMessage(Handle,WM_LBUTTONDOWN,0,0)
  114.   else inherited;
  115. end;
  116.  
  117. procedure TListBitBtn.SetItems(Items: TStrings);
  118. begin
  119.   FItems.Assign(Items);
  120. end;
  121.  
  122. procedure TListBitBtn.WMCommand(var Message: TMessage);
  123. begin
  124.   FItemIndex := Message.wParam;
  125.   if Assigned(FonChange) Then FOnChange(Self);
  126. end;
  127.  
  128. procedure TListBitBtn.MouseDown(Button: TMouseButton; Shift: TShiftState;
  129.       X, Y: Integer);
  130. var
  131. pc,pd: TPoint;
  132. hMyMenu: Hmenu;
  133. i: Integer;
  134. CCaption: array[0..255] of Char;
  135. begin
  136.  
  137.   inherited MouseDown(Button, Shift, X, Y);
  138.  
  139.   If Fitems.Count >=1 Then Begin
  140.     { Create Menu }
  141.     hMyMenu := CreatePopupMenu;
  142.     For i := 1 to FItems.Count Do
  143.       if FItems[i-1] = '-' then
  144.         appendmenu(HMyMenu,MF_MENUBREAK,i-1,nil)
  145.       else begin
  146.         StrPCopy(CCaption,FItems[i-1]);
  147.         if (FItemChecked) and (ItemIndex = i-1) then
  148.           AppendMenu(HMyMenu,MF_STRING or MF_CHECKED,i-1,CCaption)
  149.         else
  150.           AppendMenu(HMyMenu,MF_STRING,i-1,CCaption);
  151.       end;
  152.  
  153.     { Calculate Screen Co-ordiantes}
  154.     pc.x := left;
  155.     pc.y := top + Height;
  156.     With (Owner as TForm) do pd := ClientToScreen(pc);
  157.     TrackPopupMenu(HMyMenu,TPM_LEFTALIGN,pd.x,pd.y,0,Handle,nil);
  158.     DestroyMenu(HMyMenu);
  159.     PostMessage(Handle,WM_LBUTTONUP,0,0);
  160.   end;
  161. end;
  162.  
  163. {-----------------------------------------------------------------------------
  164.  TListButton
  165. -----------------------------------------------------------------------------}
  166.  
  167.  
  168. constructor tlistbutton.Create(AOwner: TComponent);
  169. begin
  170.   inherited Create(AOwner);
  171.   Fitems := TStringList.Create;
  172.   ItemIndex := -1;
  173. end;
  174.  
  175. destructor tlistbutton.Destroy;
  176. begin
  177.   Fitems.Free;
  178.   Inherited destroy;
  179. end;
  180.  
  181. procedure TListButton.WMChar(var Message: TWMChar);
  182. begin
  183.   if Message.CharCode = VK_SPACE Then PostMessage(Handle,WM_LBUTTONDOWN,0,0)
  184.   else inherited;
  185. end;
  186.  
  187. procedure tlistbutton.SetItems(Items: TStrings);
  188. begin
  189.   FItems.Assign(Items);
  190. end;
  191.  
  192. procedure tlistbutton.WMCommand(var Message: TMessage);
  193. begin
  194.   FItemIndex := Message.wParam;
  195.   if Assigned(FonChange) Then FOnChange(Self);
  196. end;
  197.  
  198. procedure tlistbutton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  199.       X, Y: Integer);
  200. var
  201. pc,pd: TPoint;
  202. hMyMenu: Hmenu;
  203. i: Integer;
  204. CCaption: array[0..255] of Char;
  205. begin
  206.  
  207.   inherited MouseDown(Button, Shift, X, Y);
  208.  
  209.   If Fitems.Count >=1 Then Begin
  210.     { Create Menu }
  211.     hMyMenu := CreatePopupMenu;
  212.     For i := 1 to FItems.Count Do
  213.       if FItems[i-1] = '-' then
  214.         appendmenu(HMyMenu,MF_MENUBREAK,i-1,nil)
  215.       else begin
  216.         StrPCopy(CCaption,FItems[i-1]);
  217.         if (FItemChecked) and (ItemIndex = i-1) then
  218.           AppendMenu(HMyMenu,MF_STRING or MF_CHECKED,i-1,CCaption)
  219.         else
  220.           AppendMenu(HMyMenu,MF_STRING,i-1,CCaption);
  221.       end;
  222.  
  223.     { Calculate Screen Co-ordiantes}
  224.     pc.x := left;
  225.     pc.y := top + Height;
  226.     With (Owner as TForm) do pd := ClientToScreen(pc);
  227.     TrackPopupMenu(HMyMenu,TPM_LEFTALIGN,pd.x,pd.y,0,Handle,nil);
  228.     DestroyMenu(HMyMenu);
  229.     PostMessage(Handle,WM_LBUTTONUP,0,0);
  230.   end;
  231. end;
  232.  
  233. {-----------------------------------------------------------------------------
  234.  TMenuBitBtn
  235. -----------------------------------------------------------------------------}
  236.  
  237. procedure TMenuBitBtn.WMChar(var Message: TWMChar);
  238. begin
  239.   if Message.CharCode = VK_SPACE Then PostMessage(Handle,WM_LBUTTONDOWN,0,0)
  240.   else inherited;
  241. end;
  242.  
  243.  
  244. procedure TMenuBitBtn.MouseDown(Button: TMouseButton; Shift: TShiftState;
  245.       X, Y: Integer);
  246. var
  247. pc,pd: TPoint;
  248. begin
  249.  
  250.   inherited MouseDown(Button, Shift, X, Y);
  251.  
  252.   If Assigned(FPopupMenu) Then Begin
  253.     pc.x := left;
  254.     pc.y := top + Height;
  255.     With (Owner as TForm) do pd := ClientToScreen(pc);
  256.     FPopupMenu.Popup(pd.x,pd.y);
  257.     PostMessage(Handle,WM_LBUTTONUP,0,0);
  258.   end;
  259. end;
  260.  
  261. {-----------------------------------------------------------------------------
  262.  TMenuButton
  263. -----------------------------------------------------------------------------}
  264.  
  265. procedure TMenuButton.WMChar(var Message: TWMChar);
  266. begin
  267.   if Message.CharCode = VK_SPACE Then PostMessage(Handle,WM_LBUTTONDOWN,0,0)
  268.   else inherited;
  269. end;
  270.  
  271. procedure TMenuButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  272.       X, Y: Integer);
  273. var
  274. pc,pd: TPoint;
  275. begin
  276.  
  277.   inherited MouseDown(Button, Shift, X, Y);
  278.  
  279.   If Assigned(FPopupMenu) Then Begin
  280.     pc.x := left;
  281.     pc.y := top + Height;
  282.     With (Owner as TForm) do pd := ClientToScreen(pc);
  283.     FPopupMenu.Popup(pd.x,pd.y);
  284.     PostMessage(Handle,WM_LBUTTONUP,0,0);
  285.   end;
  286. end;
  287.  
  288.  
  289. end.
  290.